perm filename INPOUT.SAI[PNT,HE]7 blob
sn#398927 filedate 1978-11-28 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00009 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 IFCR NOT DECLARATION($$PRGID) THENC
C00006 00003 ! saves on a file any tty input. The file can be managed only by AL_CLOSE
C00009 00004 ! input/output: altf,altrans,alframe,aldec,al_subtree,alid
C00019 00005 STRING PROCEDURE PTAKED(REFERENCE STRING SSSS)
C00024 00006 STRING PROCEDURE DYSPTAKED(REFERENCE STRING SSSS)
C00026 00007 STRING PROCEDURE DYSAASS(STRING SSSS)
C00028 00008 ! input/output: readexec,readcode,writecode,alfile,close,al_close
C00036 00009 ! dat_str
C00038 ENDMK
C⊗;
IFCR NOT DECLARATION($$PRGID) THENC
ENTRY;
BEGIN "INPOUT" ENDC
DEFINE $INPOUT=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
STRING ARRAY $NAMEFL[1:10] ; ! symbol table of files used;
INTEGER ARRAY $CHNFL[1:10,0:1]; ! open/closed and ch #;
INTEGER $ALCH; ! $ALCH=channel used for output;
INTEGER $INPCH; ! channel # for input;
INTEGER ALEOF;
INTEGER TTYEOF;
INTEGER PROCEDURE UGETF(INTEGER CHAN);
BEGIN
define UGETF = '073000;
INTEGER I,CHN; LABEL DOUGTF;
CHN←CHAN;
quick_code;
move '13,CHN;
lsh '13,5;
addi '13,UGETF;
hrlm '13,DOUGTF; ! PREPARE UGETF;
DOUGTF:
I ;
end;
RETURN(I);
END;
INTEGER PROCEDURE UGET(INTEGER CHAN);
BEGIN
define MTAPE = '072000;
LABEL ADR,ADR1,DOMTPE; INTEGER CHN;
INTEGER GMOD; GMOD←CVSIX("GODMOD");
CHN←CHAN;
quick_code;
move '13,GMOD;
movem '13,ADR;
setzm '13,adr1;
move '13,CHN;
lsh '13,5;
addi '13,MTAPE;
hrlm '13,DOMTPE;
jrst DOMTPE ;
ADR:
0 ; ! '475744555744; ! SIXBIT /GODMOD/;
ADR1: 0 ;
DOMTPE:
ADR ;
move '13,ADR1;
movem '13,CHN;
end;
RETURN(CHN);
END;
INTERNAL PROCEDURE UDATEFILE(INTEGER CHAN);
BEGIN INTEGER FLAG; INTEGER I; STRING S;
I←UGET(CHAN); CLOSE(CHAN); ! PRINT("CHAN = ",CHAN, $NAMEFL[CHAN]);
IF CHAN=$TTYCH THEN S←$TTYFL ELSE S←$ALFL;
LOOKUP(CHAN,S,FLAG);
ENTER(CHAN,S,FLAG);
USETI(CHAN,I); S←NULL;
IF CHAN≠$TTYCH THEN DO S←S&INPUT(CHAN,0) UNTIL ALEOF
ELSE DO S←S&INPUT(CHAN,0) UNTIL TTYEOF;
USETO(CHAN,I); OUT(CHAN,S);
END;
INTEGER BLANK;
INTEGER DELEQ;
INTEGER EDELEQ;
INTEGER MANYDL,LCTDL,RCTDL,AP,LRDL,PRTS,PRTLRD;
PROCEDURE PSCINT;
BEGIN
SETBREAK(EDELEQ←GETBREAK,"⊂",NULL,"IS");
SETBREAK(DELEQ←GETBREAK,"=",NULL,"IA");
SETBREAK(BLANK←GETBREAK,SP,NULL,"IR");
SETBREAK(MANYDL←GETBREAK,'73&'20&'42&'173,NULL,"IA");
SETBREAK(AP←GETBREAK,'42,NULL,"IA");
SETBREAK(PRTS←GETBREAK,"}",NULL,"IA");
SETBREAK(LCTDL←GETBREAK,"⊂",NULL,"IA");
SETBREAK(RCTDL←GETBREAK,"⊃",NULL,"IA");
SETBREAK(LRDL←GETBREAK,"⊂⊃",NULL,"IA");
SETBREAK(PRTLRD←GETBREAK,"⊂⊃{",NULL,"IA");
END;
REQUIRE PSCINT INITIALIZATION;
! saves on a file any tty input. The file can be managed only by AL_CLOSE;
! The AL_CLOSE instruction without parameters closes all open files and
asks for a new tty save file. Upon exit the file is automatically closed;
INTERNAL PROCEDURE TTYSAVE;
BEGIN
STRING ANSWER;
$TTYFL←NULL;
OUTSTR("file for TTY output=");ESC_P;
CLRBUF;
ASKUSER;
IF $CLNE
THEN BEGIN
ANSWER←NAMEFILE;
OPEN($TTYCH←GETCHAN,"DSK",0,1,2,1000,0,TTYEOF);
LOOKUP($TTYCH,ANSWER,TTYEOF);
TTYEOF←-1;
ENTER($TTYCH,ANSWER,TTYEOF);
WHILE TTYEOF
DO BEGIN
PRINT("enter failed");
ANSWER←FRCVER(ANSWER);
LOOKUP($TTYCH,ANSWER,TTYEOF);
ENTER($TTYCH,ANSWER,TTYEOF);
END;
IF ¬ TTYEOF THEN BEGIN UGETF($TTYCH); OUT($TTYCH,FF); END;
OUT($TTYCH,"{ FILE BEING WRITTEN BY POINTY "&DAT_STR& " }"&CRLF);
$OUT←TRUE;
$TTYFL←ANSWER;
$OULST←NULL;
END
ELSE $OUT←FALSE;
END;
! returns a string with the names of files used for output and their
state (open/closed);
INTERNAL STRING PROCEDURE FILE_STRING;
BEGIN
INTEGER I;STRING TS;
TS←NULL;
FOR I←1 STEP 1 UNTIL $TOTFL
DO BEGIN
IF EQU($NAMEFL[I],$ALFL)
THEN TS←TS&"*"
ELSE TS←TS&" ";
TS←TS&"OC"[1+$CHNFL[I,0] FOR 1]&":"&$NAMEFL[I]&CRLF;
END;
RETURN(TS);
END;
! input/output: altf,altrans,alframe,aldec,al_subtree,alid;
! types on the file (open on $ALCH) the frame declaration and assignment
of affixment for the frame pointed by nd. If the frame is affixed
independently an assignment instruction is generated, otherwhise an
affix instruction, with the correct type of affixment is produced;
PROCEDURE ALDEC(RPTR(FRAME) ND);
BEGIN
STRING NAME,DS,FS;
NAME←FRAME:PNAME[ND]; ! frame pname;
DS←"FRAME "&NAME&";"&CRLF; ! declaration;
IF FRAME:HOWLINKED[ND]=#INDLK
THEN FS←NAME&" ← FRAME"&STR_TR(FRAME:XF[ND])&";"&DLF
ELSE BEGIN
FS←"AFFIX "&NAME&" TO "&FRAME:PNAME[FRAME:DAD[ND]]&" AT"
&CRLF&$BLANK[1 TO 6]&"TRANS"&STR_TR(FRAME:XF[ND]);
IF FRAME:HOWLINKED[ND]=#NRGLK
THEN FS←FS&" NONRIGIDLY;"&DLF
ELSE FS←FS&" RIGIDLY;"&DLF;
END;
CPRINT($ALCH,DS,FS);
END;
! finds the different frames looking at the frame tree;
PROCEDURE MC_OUT(RPTR(SYMBOL) EEE; STRING PR(NULL));
BEGIN
STRING MS;
MS ← EWDYSCODE(EEE);
IF EQU(PR,"PRETTY")
THEN PWDSPL(MS)
ELSE EWDSPL(MS,WR_M);
END;
RECURSIVE PROCEDURE FR_OUT(RPTR(FRAME) ND);
BEGIN
RPTR(FRAME) SN;
IF ND≠F_WRLD THEN ALDEC(ND);
SN←FRAME:SON[ND];
WHILE SN≠NULL_RECORD
DO BEGIN
FR_OUT(SN);
SN←FRAME:EBRO[SN];
END;
END;
! types on the file (open on $ALCH) the scalar declarations and
assignments;
PROCEDURE ST_OUT(INTEGER TYPE; STRING PR(NULL));
BEGIN "U"
INTEGER ADDRIN,ADDRFN,I;
RPTR(SYMBOL)ADDR;STRING DS,VS;
ADDRIN←#LTYPE*(TYPE-#MIN); ! initial address in $YMTAB;
ADDRFN←$ENTRY[TYPE]-1; ! final address;
DS←VS←NULL;
FOR I←ADDRIN STEP 1 UNTIL ADDRFN DO
BEGIN "D"
ADDR←$YMTAB[I]; ! if null_record is a deleted symb;
IF ADDR≠NULL_RECORD
THEN CASE TYPE OF
BEGIN "CASE"
[#SC]
BEGIN "SC"
DS←"SCALAR "&SYMBOL:PNAME[ADDR]&";"&CRLF;
VS←SYMBOL:PNAME[ADDR]&" ← "
&CVGX(SCALAR:VALUE[SYMBOL:OBJECT[ADDR]])&";"&DLF;
CPRINT($ALCH,DS,VS);
END "SC";
[#VT]
BEGIN "VT"
RPTR(VECTOR)IND;
IND←SYMBOL:OBJECT[ADDR];
DS←"DISTANCE VECTOR "&SYMBOL:PNAME[ADDR]&";"&CRLF;
VS←SYMBOL:PNAME[ADDR]&" ← "
&STR_VT(VECTOR:XC[IND],VECTOR:YC[IND],
VECTOR:ZC[IND]) &";"&DLF;
CPRINT($ALCH,DS,VS);
END "VT";
[#RT]
BEGIN "RT"
DS←"ROT "&SYMBOL:PNAME[ADDR]&";"&CRLF;
VS←SYMBOL:PNAME[ADDR]&" ← "
&STR_RT(ROT:XF[SYMBOL:OBJECT[ADDR]])&";"&DLF;
CPRINT($ALCH,DS,VS);
END "RT";
[#TR] BEGIN "TR"
DS←"TRANS "&SYMBOL:PNAME[ADDR]&";"&CRLF;
VS←SYMBOL:PNAME[ADDR]&" ← TRANS"
&STR_TR(TRANS:XF[SYMBOL:OBJECT[ADDR]])&";"&DLF;
CPRINT($ALCH,DS,VS);
END "TR";
[#MC] BEGIN "MC"
DS ← EWDYSCODE(ADDR);
IF EQU(PR,"PRETTY")
THEN PWDSPL(DS)
ELSE EWDSPL(DS, WR_M);
END "MC"
END "CASE";
END "D";
END "U";
INTERNAL STRING PROCEDURE EWDYSCODE(RPTR(SYMBOL) EL1);
BEGIN
STRING SM,SPS;
RPTR(MACRO) TEMP;
RPTR(PLIST) PPML;
TEMP ← SYMBOL:OBJECT[EL1];
SM ← "DEFINE" & '40 & SYMBOL:PNAME[EL1];
IF MACRO:NPARAM[TEMP] ≠ 0
THEN BEGIN
SPS ← NULL;
PPML ← MACRO:PARLST[TEMP];
SPS ← PLIST:PARAM[PPML];
PPML ← PLIST:NEXTP[PPML];
WHILE PPML ≠ NULL_RECORD
DO BEGIN
SPS ← PLIST:PARAM[PPML] & "," & SPS;
PPML ← PLIST:NEXTP[PPML];
END;
SM ← SM & "(" & SPS & ")";
END;
SM ← SM & '40 & "=" & '40
& "⊂" & '40 & MACRO:BODY[TEMP] & "⊃" & ";";
RETURN (SM);
END;
STRING PROCEDURE TAKEPS(REFERENCE STRING SSSS; INTEGER LOPFOR);
BEGIN
INTEGER BRCHAR, LRAPP, LREVS, I;
STRING REVS, RAPP, APP, SPART, LASTBL;
REVS ← NULL;
APP ← NULL;
SPART ← NULL;
FOR I ← 1 STEP 1 UNTIL LOPFOR
DO BEGIN
REVS ← LOP(SSSS) & REVS;
IF EQU(SSSS,NULL) THEN DONE;
END;
LASTBL ← REVS;
IF LOP(LASTBL) NEQ " " AND SSSS NEQ NULL
THEN BEGIN
RAPP ← SCAN(REVS,BLANK,BRCHAR);
LRAPP ← LENGTH(RAPP);
FOR I ← 1 STEP 1 UNTIL LRAPP
DO APP ← LOP(RAPP) & APP;
SSSS ← APP & SSSS;
END;
LREVS ← LENGTH(REVS);
FOR I ← 1 STEP 1 UNTIL LREVS
DO SPART ← LOP(REVS) & SPART;
RETURN(SPART);
END;
PROCEDURE WRCP(REFERENCE STRING SSSS);
BEGIN
INTEGER BRCHAR;
STRING SWR, DEFPAR;
DEFPAR ← SCAN(SSSS,DELEQ,BRCHAR);
CPRINT($ALCH,DEFPAR & CRLF);
IF LENGTH(SSSS) ≥ 84
THEN WHILE TRUE
DO BEGIN
SWR ← TAKEPS(SSSS,82);
CPRINT($ALCH, SWR & CRLF);
IF EQU(SSSS,NULL)
THEN DONE;
END
ELSE CPRINT($ALCH,SSSS & CRLF);
CPRINT($ALCH,CRLF);
END;
INTERNAL PROCEDURE EWDSPL(STRING SSSS; INTEGER TYPOUT);
BEGIN
IF LENGTH(SSSS) ≥ 128
THEN CASE TYPOUT OF
BEGIN
[WR_M] WRCP(SSSS);
[ED_M] BEGIN
STRING GLOBS, LODS;
PRINT(
"PLEASE EDIT LINE BY LINE, TRY NOT TO EXCEED 140 CARACTERS FOR LINE", CRLF);
GLOBS ← NULL;
DO BEGIN
LODS ← TAKEPS(SSSS, 82);
LODED(LODS & CR);
GLOBS ← GLOBS & INCHWL;
END
UNTIL EQU(SSSS, NULL);
ASKUSER(GLOBS);
END
END
ELSE IF LENGTH(SSSS) ≥ 84
THEN CASE TYPOUT OF
BEGIN
[WR_M] WRCP(SSSS);
[ED_M] BEGIN
PRINT(
"IF EXTEND MACRO, PLEASE CLOSE AND EDIT IT AGAIN AFTER THE 128TH CARACTER", CRLF);
LODED(SSSS & CR);
ASKUSER;
END
END
ELSE CASE TYPOUT OF
BEGIN
[WR_M] CPRINT($ALCH, SSSS & CRLF & LF);
[ED_M] BEGIN
LODED(SSSS & CR);
ASKUSER;
END
END;
END;
STRING PROCEDURE PTAKED(REFERENCE STRING SSSS);
BEGIN
INTEGER CHAR;
STRING DEFPAR;
DEFPAR ← SCAN(SSSS,EDELEQ,CHAR);
RETURN (DEFPAR);
END;
STRING PROCEDURE PTAKES(REFERENCE STRING SSSS);
BEGIN
INTEGER CTDL, BRCHAR;
STRING TEMPS;
TEMPS ← NULL;
WHILE TRUE
DO BEGIN
CTDL ← 0;
TEMPS ← TEMPS & SCAN(SSSS,MANYDL,BRCHAR);
IF BRCHAR = '42
THEN TEMPS ← TEMPS & SCAN(SSSS,AP,BRCHAR)
ELSE IF BRCHAR = "{"
THEN TEMPS ← TEMPS & SCAN(SSSS,PRTS,BRCHAR)
ELSE IF BRCHAR = "⊂"
THEN BEGIN
CTDL ← CTDL+1;
WHILE TRUE
DO BEGIN
TEMPS ← TEMPS & SCAN(SSSS,PRTLRD,BRCHAR);
IF BRCHAR = "{"
THEN TEMPS ← TEMPS & SCAN(SSSS,PRTS,BRCHAR)
ELSE BEGIN
IF BRCHAR = "⊂"
THEN CTDL ← CTDL+1
ELSE CTDL ← CTDL-1;
IF CTDL = 0 THEN DONE;
END;
END;
END
ELSE DONE;
END;
RETURN(TEMPS);
END;
PROCEDURE WDLINE(STRING TEMPL);
BEGIN
STRING LTEMPL;
IF LENGTH(TEMPL) ≥ 76
THEN
BEGIN
LTEMPL ← TAKEPS(TEMPL, 74);
CPRINT($ALCH, TABDEF); CPRINT($ALCH, LTEMPL & CRLF);
IF TEMPL NEQ NULL
THEN DO BEGIN
LTEMPL ← TAKEPS(TEMPL, 74);
CPRINT($ALCH, TABDEF & SP & LTEMPL & CRLF);
END
UNTIL EQU(TEMPL, NULL);
END
ELSE
CPRINT($ALCH, TABDEF & TEMPL & CRLF);
END;
PROCEDURE WDLINH(STRING TEMPL; INTEGER LENGLL);
BEGIN
STRING LTEMPL;
IF LENGTH(TEMPL) ≥ (82-LENGLL)
THEN
BEGIN
LTEMPL ← TAKEPS(TEMPL, 80-LENGLL);
CPRINT($ALCH,"⊂" & SP & LTEMPL & CRLF);
IF TEMPL NEQ NULL
THEN DO BEGIN
LTEMPL ← TAKEPS(TEMPL, 74);
CPRINT($ALCH, TABDEF & LTEMPL & CRLF);
END
UNTIL EQU(TEMPL, NULL);
CPRINT($ALCH,CRLF);
END
ELSE
CPRINT($ALCH, "⊂" & TEMPL & CRLF & CRLF);
END;
PROCEDURE WDDLSC;
BEGIN
CPRINT($ALCH, TABDEF&SP& "⊃;" & CRLF & CRLF);
END;
INTERNAL PROCEDURE PWDSPL(STRING SSSS);
BEGIN
STRING TEMPL, ENDS, LTEMPL, COPYTE;
INTEGER LLLTEM;
TEMPL ← PTAKED(SSSS);
LLLTEM ← LENGTH(TEMPL);
CPRINT($ALCH,TEMPL);
TEMPL ← PTAKES(SSSS);
COPYTE ← TEMPL;
IF EQU(SSSS,NULL)
THEN IF EQU(LOP(COPYTE[∞-3 TO ∞]), ";") ! the end of templ is SP&⊃&SC ;
THEN BEGIN
BEGIN
CPRINT($ALCH,CRLF & TABDEF & SP & "⊂" & CRLF);
WDLINE(TEMPL[1 TO ∞-2]);
END;
WDDLSC;
END
ELSE WDLINH(TEMPL,LLLTEM)
ELSE BEGIN
BEGIN
CPRINT($ALCH,CRLF & TABDEF & SP & "⊂" & CRLF);
WDLINE(TEMPL);
END;
WHILE TRUE
DO BEGIN
TEMPL ← PTAKES(SSSS);
IF EQU(SSSS,NULL)
THEN BEGIN
IF EQU(TEMPL," ⊃;")
THEN BEGIN
WDDLSC;
DONE;
END
ELSE
BEGIN
WDLINE(TEMPL[1 TO ∞-2]);
WDDLSC;
DONE;
END;
END
ELSE
WDLINE(TEMPL);
END;
END;
END;
STRING PROCEDURE DYSPTAKED(REFERENCE STRING SSSS);
BEGIN
INTEGER CHAR;
STRING DEFPAR;
DEFPAR ← SCAN(SSSS,LCTDL,CHAR);
RETURN (DEFPAR[8 TO ∞]);
END;
STRING PROCEDURE DYSLINH(STRING TEMPL; REFERENCE STRING AASS; INTEGER LENGLL);
BEGIN
STRING LTEMPL, APPS;
IF LENGTH(TEMPL) ≥ (82-LENGLL)
THEN BEGIN
LTEMPL ← TAKEPS(TEMPL, 82-LENGLL);
APPS ← LTEMPL & CRLF;
DO BEGIN
LTEMPL ← TAKEPS(TEMPL, 82);
APPS ← APPS & LTEMPL & CRLF;
END
UNTIL EQU(TEMPL, NULL);
END
ELSE
APPS ← TEMPL & CRLF;
AASS ← AASS & APPS;
RETURN(AASS);
END;
STRING PROCEDURE DYSLINE(STRING TEMPL; REFERENCE STRING AASS);
BEGIN
STRING LTEMPL, APPS;
APPS ← NULL;
IF LENGTH(TEMPL) ≥ 82
THEN DO BEGIN
LTEMPL ← TAKEPS(TEMPL, 82);
APPS ← APPS & LTEMPL & CRLF;
END
UNTIL EQU(TEMPL,NULL)
ELSE APPS ← TEMPL & CRLF;
AASS ← AASS & APPS;
RETURN(AASS);
END;
STRING PROCEDURE DYSAASS(STRING SSSS);
BEGIN
STRING TEMPL, ENDS, LTEMPL, COPYTE, AASS, NNSS;
INTEGER LLLTEM;
AASS ← DYSPTAKED(SSSS);
LLLTEM ← LENGTH(AASS);
TEMPL ← PTAKES(SSSS);
COPYTE ← TEMPL;
IF EQU(SSSS,NULL)
THEN BEGIN
NNSS ← NULL;
IF EQU(LOP(COPYTE[∞-3 TO ∞]), ";") ! the end of templ is SP&⊃&SC ;
THEN BEGIN
AASS ← AASS & CRLF ;
AASS ← DYSLINE(TEMPL,AASS);
END
ELSE AASS ← DYSLINH(TEMPL,AASS,LLLTEM);
END
ELSE BEGIN
AASS ← AASS & CRLF;
AASS ← DYSLINE(TEMPL,AASS);
DO BEGIN
TEMPL ← PTAKES(SSSS);
AASS ← DYSLINE(TEMPL,AASS);
END
UNTIL EQU(SSSS,NULL);
END;
IF EQU(AASS[∞-7 TO ∞], ";" & CRLF & SP & "⊃" & ";" & CRLF)
THEN AASS ← AASS[1 TO ∞-7] & SP & "⊃" & ";" & CRLF;
RETURN(AASS);
END;
INTERNAL STRING PROCEDURE MACDYS(RPTR(SYMBOL) TMAC);
BEGIN
STRING MACRLS, AAA;
MACRLS ← EWDYSCODE(TMAC);
AAA ← DYSAASS(MACRLS);
RETURN(AAA);
END;
! input/output: readexec,readcode,writecode,alfile,close,al_close;
! if the file has been previously used returns its number in table,
otherwise returns 0;
INTERNAL INTEGER PROCEDURE ISFILE(STRING FILE);
BEGIN
INTEGER I;
FOR I←1 STEP 1 UNTIL $TOTFL DO
IF EQU($NAMEFL[I],FILE) THEN RETURN (I);
RETURN(0);
END;
SIMPLE PROCEDURE OPENFL(REFERENCE STRING FILE;INTEGER IND(0));
BEGIN
INTEGER $NOEXIST;
OPEN($ALCH←GETCHAN,"DSK",0,1,2,1000,0,ALEOF);
ALEOF←-1;
LOOKUP($ALCH,FILE,$NOEXIST);
ENTER($ALCH,FILE,ALEOF);
WHILE ALEOF
DO BEGIN
PRINT(" enter failed ");
FILE←FRCVER(FILE);
ENTER($ALCH,FILE,ALEOF);
END;
IF IND>0
THEN BEGIN
$CHNFL[IND,0]←0; ! file existent closed;
$CHNFL[IND,1]←$ALCH;
END
ELSE BEGIN
$TOTFL←$TOTFL+1; ! one new file;
IF $TOTFL>10 THEN ERROR("Ten AL files open, cant open any more");
$NAMEFL[$TOTFL]←FILE; ! name;
$CHNFL[$TOTFL,1]←$ALCH; ! channel number;
$CHNFL[$TOTFL,0]←0; ! file open;
END;
IF ¬$NOEXIST THEN BEGIN UGETF($ALCH); OUT($ALCH,FF); END;
OUT($ALCH,"{ FILE BEING WRITTEN BY POINTY : "&DAT_STR&" }"&CRLF);
$OULST←NULL; ! file status modified;
END;
INTERNAL PROCEDURE FCLOSE;
BEGIN
INTEGER IND;
FOR IND←1 STEP 1 UNTIL $TOTFL DO
BEGIN
$CHNFL[IND,0]←1; ! sets the file closed in table;
PRINT("CLOSING ",$NAMEFL[IND],CRLF); ESC_P;
RELEASE($CHNFL[IND,1]); ! releases channels;
$ALFL←"DECLAR.AL"; ! new default file;
END;
IF $OUT
THEN BEGIN
PRINT("CLOSING ",$TTYFL,CRLF);ESC_P;
RELEASE($TTYCH,0); ! closes the tty save file;
$OUT←FALSE; ! sets the flag;
END;
END;
! close the file open;
INTERNAL PROCEDURE AL_CLOSE(STRING FILE );
BEGIN
INTEGER IND;
IND←ISFILE(FILE); ! address of file in table;
IF IND=0 THEN ERROR(FILE&" is not open");
$CHNFL[IND,0]←1; ! closes the file;
RELEASE($CHNFL[IND,1]);
! looks for an open file: if no file is open DECLAR.AL is proposed;
$ALFL←"DECLAR.AL";
IND←$TOTFL;
WHILE IND DO
IF $CHNFL[IND,0]
THEN IND←IND-1
ELSE BEGIN
$ALFL←$NAMEFL[IND]; ! name of open file;
DONE;
END;
$OULST←NULL; ! file status modified;
END;
INTERNAL PROCEDURE WRITECODE(STRING FILE;RPTR(SYMBOL) ELEMENT;
INTEGER DTYPE;STRING DEFPR);
BEGIN
INTEGER IND;
! checks if file exists and if it's open, otherwise open it;
IND←ISFILE(FILE);
IF IND = 0
THEN OPENFL(FILE)
ELSE IF $CHNFL[IND,0]
THEN BEGIN
! STRING STR;
! PRINT("file existent, but closed (type Y to overwrite)");
! STR←INCHRW;
! IF STR=CR THEN STR←INCHRW;
! PRINT(CRLF);
! IF STR="Y" OR str="y"
THEN OPENFL(FILE,IND)
ELSE ABORT1("not executed instruction");
OPENFL(FILE,IND);
END
ELSE $ALCH←$CHNFL[IND,1]; ! channel number;
! updates information for display;
IF NOT EQU(FILE,$ALFL)
THEN BEGIN
$ALFL←FILE; ! last file used for output;
$OULST←NULL;
END;
! output on the file;
IF ELEMENT=NULL_RECORD
THEN BEGIN
ST_OUT(#SC); ! outputs the scalars;
ST_OUT(#VT); ! outputs th vectors;
ST_OUT(#RT); ! outputs the rotations;
ST_OUT(#TR); ! outputs the transes;
FR_OUT(SYMBOL:OBJECT[WORLD]); ! outputs the frame tree;
ST_OUT(#MC,DEFPR); ! outputs the macros;
END
ELSE CASE DTYPE OF
BEGIN
[#SC]
BEGIN "SC" STRING DS,VS;
DS←"SCALAR "&SYMBOL:PNAME[ELEMENT]&";"&CRLF;
VS←SYMBOL:PNAME[ELEMENT]&" ← "
&CVGX(SCALAR:VALUE[SYMBOL:OBJECT[ELEMENT]])&";"&DLF;
CPRINT($ALCH,DS,VS);
END "SC";
[#VT]
BEGIN "VT"
RPTR(VECTOR)IND; STRING DS,VS;
IND←SYMBOL:OBJECT[ELEMENT];
DS←"DISTANCE VECTOR "&SYMBOL:PNAME[ELEMENT]&";"&CRLF;
VS←SYMBOL:PNAME[ELEMENT]&" ← "
&STR_VT(VECTOR:XC[IND],VECTOR:YC[IND],
VECTOR:ZC[IND]) &";"&DLF;
CPRINT($ALCH,DS,VS);
END "VT";
[#RT]
BEGIN "RT" STRING DS,VS;
DS←"ROT "&SYMBOL:PNAME[ELEMENT]&";"&CRLF;
VS←SYMBOL:PNAME[ELEMENT]&" ← "
&STR_RT(ROT:XF[SYMBOL:OBJECT[ELEMENT]])&";"&DLF;
CPRINT($ALCH,DS,VS);
END "RT";
[#TR]
BEGIN "TR" STRING DS,VS;
DS←"TRANS "&SYMBOL:PNAME[ELEMENT]&";"&CRLF;
VS←SYMBOL:PNAME[ELEMENT]&" ← TRANS"
&STR_TR(TRANS:XF[SYMBOL:OBJECT[ELEMENT]])&";"&DLF;
CPRINT($ALCH,DS,VS);
END "TR";
[#FR] FR_OUT(SYMBOL:OBJECT[ELEMENT]);
[#MC] MC_OUT(ELEMENT,DEFPR);
[#FN] OUTSTR("can't output functions yet")
END;
UDATEFILE($ALCH);
END;
! dat_str;
PRESET_WITH "Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sept","Oct","Nov","Dec";
STRING ARRAY $MONTH[0:11];
INTERNAL STRING PROCEDURE DAT_STR;
BEGIN
INTEGER SDATE,SSEC; integer width,digits;
INTEGER YEAR,MONTH,DATE,HOUR,MINUTE,SECOND;
STRING DATE_STRING;
comment using ACCTIM UUO;
quick_code;
calli '13,'400101;
hlrzm '13,SDATE;
hrrzm '13,SSEC;
end;
DATE←SDATE MOD 31;
SDATE←SDATE DIV 31;
MONTH←SDATE MOD 12;
YEAR←(SDATE DIV 12) + 1964;
SECOND←SSEC MOD 60;
SSEC←SSEC DIV 60;
MINUTE←SSEC MOD 60;
HOUR←SSEC DIV 60;
GETFORMAT(WIDTH,DIGITS);
SETFORMAT(0,0);
DATE_STRING←CVS(HOUR)&":";
SETFORMAT(-2,0);
DATE_STRING←DATE_STRING&CVS(MINUTE)&" ";
SETFORMAT(0,0);
DATE_STRING←DATE_STRING&CVS(DATE+1)&" "&$MONTH[MONTH]&" "&CVS(YEAR);
SETFORMAT(WIDTH,DIGITS);
RETURN(DATE_STRING);
END;
END "INPOUT";